Monster Media 1994 #2/Monster Media No. 2 (Monster Media)(1994).ISO/prog_gen/qshade.zip/TOOLS.PAS

Pascal/Delphi Source File | 1994-06-04 | 5KB | 249 lines

(*
  ──────────────────────
  String Tools unit v1.1
  ──────────────────────
  (c)1994   Rsc Research

  Write me at:     or on Compuserve
  ────────────     ────────────────
  Cédric Rime           100340,2736
  Dixence 21
  1950 Sion
  Switzerland


  This program is entered as Shareware.
  If you find it useful, a small donation would be appreciated.(then i can take some English lessons!!!)

  Feel free to incorporate the code into your own programs.

*)


UNIT tools;
INTERFACE
USES crt,dos;

CONST KeyUP=72;
      KeyDOWN=80;
      KeyRIGHT=77;
      KeyLEFT=75;
      KeyHome=71;
      KeyEnd=79;
      KeyPGup=73;
      KeyPGDown=81;
      KeyEsc=27;
      KeyEnter=13;
      KeyBackSpace=8;
      KeyTab=9;

FUNCTION rval(st:STRING):real;
FUNCTION rstr(r:real):STRING;
FUNCTION ival(st:STRING):INTEGER;
FUNCTION istr(r:INTEGER):STRING;
FUNCTION toupper(st:STRING):STRING;
FUNCTION tolower(st:STRING):STRING;
FUNCTION from(st:STRING;x:BYTE):STRING;
FUNCTION right(st:STRING;x:BYTE):STRING;
FUNCTION left(st:STRING;x:BYTE):STRING;
FUNCTION spc(w:BYTE):STRING;
FUNCTION xcopy(nom,nom2:STRING):BOOLEAN;
FUNCTION xerase(nom:STRING):BOOLEAN;
FUNCTION xrename(nom,nom2:STRING):BOOLEAN;
FUNCTION exist(nom:STRING):BOOLEAN;
FUNCTION stringtonumber(y:STRING):real;
FUNCTION Hex2Int(h:STRING):LongInt;

IMPLEMENTATION

FUNCTION Hex2Int(h:STRING):LongInt;
CONST v='0123456789ABCDEF';
VAR   q:INTEGER;
      m:LongInt;
      res:LongInt;
      s:STRING;
BEGIN
s:=toupper(h);
m:=1;res:=0;
FOR q:=Length(s) DOWNTO 1 DO
    BEGIN
     res:=res+(Pos(Copy(s,q,1),v)-1)*m;
     m:=m SHL 4;
    END;
hex2int:=res;
END;

FUNCTION StringToNumber(y:STRING):real;
VAR q,w,e:INTEGER;
    r:real;
    a,s:STRING;
    l:BYTE;
CONST Inum='0123456789';

PROCEDURE clean1;
VAR q:INTEGER;
BEGIN
FOR q:=1 TO l DO IF (Pos(Copy(y,q,1),inum)>0) AND (Pos(Copy(y,q,1),inum)<11) THEN a:=a+Copy(y,q,1);
END;

PROCEDURE clean2;
VAR q,w:INTEGER;
BEGIN
w:=0;
FOR q:=1 TO l DO IF (Pos(Copy(y,q,1),inum)>0) AND (Pos(Copy(y,q,1),inum)<11) THEN a:=a+Copy(y,q,1)
    ELSE IF (Copy(y,q,1)='.') AND (w=0) THEN BEGIN a:=a+Copy(y,q,1);w:=1;END;
END;

BEGIN
l:=Length(y);IF l<1 THEN BEGIN stringtonumber:=0;EXIT;END;
a:='';
IF (Pos('.',y)>0) AND (Pos('.',y)<=l) THEN
   BEGIN {float number}
   clean2;
   END ELSE
   BEGIN {integer number}
   clean1;
   END;
IF a='.' THEN a:='0';
IF Copy(a,Length(a),1)='.' THEN a:=Copy(a,1,Length(a)-1);
Val(a,r,q);
stringtonumber:=r;
END;
FUNCTION rval(st:STRING):real;
VAR d:INTEGER;
    f:real;
BEGIN
Val(st,f,d);
rval:=f;
END;

FUNCTION rstr(r:real):STRING;
VAR d:INTEGER;
    f:STRING;
BEGIN
Str(r,f);
rstr:=f;
END;

FUNCTION ival(st:STRING):INTEGER;
VAR d:INTEGER;
    f:INTEGER;
BEGIN
Val(st,f,d);
ival:=f;
END;

FUNCTION istr(r:INTEGER):STRING;
VAR d:INTEGER;
    f:STRING;
BEGIN
Str(r,f);
istr:=f;
END;

FUNCTION toupper(st:STRING):STRING;
VAR q:BYTE;
    s:STRING;
    dn,up:STRING;
BEGIN
DN:='abcdefghijklmnopqrstuvwxyzèéà';
up:='ABCDEFGHIJKLMNOPQRSTUVWXYZEEA';
s:='';
FOR q:=1 TO Length(st) DO IF Pos(st[q],dn)<>0 THEN s:=s+up[Pos(st[q],dn)] ELSE s:=s+st[q];
toupper:=s;
END;

FUNCTION tolower(st:STRING):STRING;
VAR q:BYTE;
    s:STRING;
    up,dn:STRING;
BEGIN
DN:='abcdefghijklmnopqrstuvwxyzèéà';
up:='ABCDEFGHIJKLMNOPQRSTUVWXYZEEA';
s:='';
FOR q:=1 TO Length(st) DO IF Pos(st[q],up)<>0 THEN s:=s+dn[Pos(st[q],up)] ELSE s:=s+st[q];
tolower:=s;
END;

FUNCTION from(st:STRING;x:BYTE):STRING;
BEGIN
from:=Copy(st,x,Length(st)-x);
END;

FUNCTION right(st:STRING;x:BYTE):STRING;
BEGIN
right:=Copy(st,Length(st)-x,x);
END;

FUNCTION left(st:STRING;x:BYTE):STRING;
BEGIN
left:=Copy(st,1,x);
END;

FUNCTION  spc(w:BYTE):STRING;
VAR qqq:STRING;
    q:BYTE;
BEGIN
qqq:='';
FOR q:=1 TO w DO qqq:=qqq+' ';
spc:=qqq;
END;
FUNCTION xerase(nom:STRING):BOOLEAN;
VAR f:FILE;
BEGIN
xerase:=TRUE;
Assign(f,nom);
{$i-}Rewrite(f,1);{$i+} IF IOResult<>0 THEN xerase:=FALSE;
Close(f);
Erase(f);
END;
FUNCTION xrename(nom,nom2:STRING):BOOLEAN;
VAR f:FILE;
BEGIN
xrename:=TRUE;
Assign(f,nom);
{$i-}Reset(f,1);{$i+} IF IOResult<>0 THEN xrename:=FALSE;
Close(f);
Rename(f,nom2);
END;
FUNCTION xcopy(nom,nom2:STRING):BOOLEAN;
VAR f,f1:FILE;
    buff:ARRAY[0..4096] OF BYTE;
    lng:LongInt;
PROCEDURE one;
BEGIN
BlockRead(f,buff,lng);
BlockWrite(f1,buff,lng);
lng:=0;
END;
PROCEDURE two;
BEGIN
BlockRead(f,buff,4095);
BlockWrite(f1,buff,4095);
lng:=lng-4095;
END;

BEGIN
xcopy:=TRUE;
Assign(f,nom);
{$i-}Reset(f,1);{$i+} IF IOResult<>0 THEN xcopy:=FALSE;
Assign(f1,nom2);
{$i-}Reset(f,1);{$i+} IF IOResult<>0 THEN xcopy:=FALSE;
lng:=FileSize(f);
REPEAT
IF lng<4095 THEN one ELSE two;
UNTIL lng<1;
Close(f);
Close(f1);
END;

FUNCTION exist(nom:STRING):BOOLEAN;
VAR tttx:FILE;
BEGIN
Assign(tttx,nom);
{$i-}Reset(tttx,1);{$i+}
exist:=TRUE;
IF IOResult<>0 THEN exist:=FALSE;
END;
END.